Option Explicit

Private bAbortMacro As Boolean

Private CustomTextCursor1 As CTextCursor
Private CustomTextCursor2 As CTextCursor
Private CustomTextCursor3 As CTextCursor

Sub StartLongMacro()
 
    Dim t As Single
    Dim lRow As Long
    
    Set CustomTextCursor1 = New CTextCursor
    Set CustomTextCursor2 = New CTextCursor
    Set CustomTextCursor3 = New CTextCursor
    
    CustomTextCursor1.Add Text:="Loading In Progress .", Color:=vbBlack
    CustomTextCursor2.Add Text:="Loading In Progress ..", Color:=vbRed
    CustomTextCursor3.Add Text:="Loading In Progress ...", Color:=vbBlue
    
    bAbortMacro = False
    
    t = Timer
    
    For lRow = 1 To Rows.Count
    
        Select Case True
        
            Case (Timer - t) Mod 3 = 0
                CustomTextCursor1.Show
            Case (Timer - t) Mod 3 = 1
                CustomTextCursor2.Show
            Case (Timer - t) Mod 3 = 2
                CustomTextCursor3.Show
        
        End Select
        
        Randomize
        
        Cells(lRow, 1) = Int((100 * Rnd) + 1)
        
        If bAbortMacro Then Exit For
        
        DoEvents
    
    Next
    
    CustomTextCursor1.Destroy
    CustomTextCursor2.Destroy
    CustomTextCursor3.Destroy


End Sub


Sub AbortMacro()

    bAbortMacro = True
    Columns("A:A").ClearContents
    
End Sub

'*******************************
' // This code Creates a Custom Text Cursor.
'*******************************
Option Explicit
 
'=============================
' // Private Declarations..
'=============================
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
    bmiHeader As BITMAPINFOHEADER
End Type
 
 
Private Type MemoryBitmap
    hdc As Long
    hBM As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO_NoColors
End Type
 

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) _
As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
 
Private Declare Function GetPixel Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long) _
As Long

Private Declare Function SetPixel Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal crColor As Long) _
As Long
 
Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long
 
Private Declare Function TextOut Lib "gdi32.dll" _
Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long, ByVal lpString As String, _
ByVal nCount As Long) _
As Long
 
Private Declare Function CreateIconIndirect Lib "user32.dll" _
(ByRef piconinfo As ICONINFO) _
As Long

Private Declare Function SetCursor Lib "user32.dll" _
(ByVal hCursor As Long) _
As Long

Private Declare Function DestroyIcon Lib "user32.dll" _
(ByVal hIcon As Long) _
As Long
 
Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As POINTAPI) _
As Long
 
Private Declare Function SetTextColor Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal crColor As Long) _
As Long

Private Declare Function WindowFromPoint Lib "user32.dll" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) _
As Long
 
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) _
As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () _
As Long

Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) _
As Long
 
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
 
Private sText As String
Private lTextColor As Long
Private hCursor As Long


'=============================
' // Private Procedures ..
'=============================

Private Function TextToBitmap _
( _
Text As String, TextColor As Long _
 _
) As Boolean

    Dim memory_bitmap As MemoryBitmap
    
    On Error GoTo errHandler
    
    'Store all the arguments for later use.
    sText = Text
    lTextColor = TextColor
    ' Create the memory bitmap.
    memory_bitmap = MakeMemoryBitmap _
    (Text, TextColor)
    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap
    
    'create memory cursor masks.
    Call GetMaskBitmaps(memory_bitmap)
    
    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap
    
    'Return TRUE if success.
    TextToBitmap = True
    
    Exit Function
    
errHandler:
    MsgBox Err.Description, vbCritical, "Error"
 
End Function
 
' Make a memory bitmap according to the Font size.
Private Function MakeMemoryBitmap _
( _
Text As String, Color As Long _
) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
    Dim TextSize As POINTAPI
    Dim new_font As Long
 
    ' Create the device context.
    result.hdc = CreateCompatibleDC(0)
 
    'get the text metrics.
    GetTextExtentPoint32 result.hdc, Text, Len(Text), TextSize
 
    ' Define the bitmap.
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = TextSize.x 'wid
        .biHeight = TextSize.y ' hgt
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
        31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
        * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
 
    ' Create the bitmap.
    result.hBM = CreateDIBSection( _
    result.hdc, result.bitmap_info, _
    DIB_RGB_COLORS, ByVal 0&, _
    ByVal 0&, ByVal 0&)
 
    ' Make the device context use the bitmap.
    result.oldhDC = SelectObject(result.hdc, result.hBM)
 
    ' Return the MemoryBitmap structure.
    result.wid = TextSize.x
    result.hgt = TextSize.y
 
    MakeMemoryBitmap = result
 
End Function
 
Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap _
)
 
    SetBkMode memory_bitmap.hdc, 2 'Opaque
    SetTextColor memory_bitmap.hdc, lTextColor
    TextOut memory_bitmap.hdc, 0, 0, Trim(sText), Len(Trim(sText))
 
End Sub
 
' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)
 
    SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hBM
    DeleteDC memory_bitmap.hdc
 
End Sub


Private Sub GetMaskBitmaps( _
memory_bitmap As MemoryBitmap _
)

    Dim tIcoInfo As ICONINFO
    Dim hMainDC As Long
    Dim hAndMaskDC As Long
    Dim hXorMaskDC As Long
    Dim hAndMaskBitmap As Long
    Dim hXorMaskBitmap As Long
    Dim hOldMainBmp As Long
    Dim lOldAndMaskBmp As Long
    Dim lOldXorMaskBmp As Long
    Dim x As Long, y As Long
    
    'create the memory DCs.
    hMainDC = memory_bitmap.hdc
    hAndMaskDC = CreateCompatibleDC(hMainDC)
    hXorMaskDC = CreateCompatibleDC(hMainDC)
    
    'create the memory BMPs.
    hAndMaskBitmap = CreateCompatibleBitmap _
    (hMainDC, memory_bitmap.wid, memory_bitmap.hgt)
    hXorMaskBitmap = CreateCompatibleBitmap _
    (hMainDC, memory_bitmap.wid, memory_bitmap.hgt)
    
    'select the Mem BMPs onto the Mem DCs.
     hOldMainBmp = SelectObject(hMainDC, memory_bitmap.hBM)
     lOldAndMaskBmp = SelectObject(hAndMaskDC, hAndMaskBitmap)
     lOldXorMaskBmp = SelectObject(hXorMaskDC, hXorMaskBitmap)
    
    'set the masks pixels in the msks DCs.
    For x = 0 To memory_bitmap.wid
        For y = 0 To memory_bitmap.hgt
            If GetPixel(hMainDC, x, y) = RGB(255, 255, 255) Then
                SetPixel hAndMaskDC, x, y, RGB(255, 255, 255)
                SetPixel hXorMaskDC, x, y, RGB(0, 0, 0)
            Else
                SetPixel hAndMaskDC, x, y, RGB(0, 0, 0)
                SetPixel hXorMaskDC, x, y, lTextColor
            End If
        Next y
    Next x
    
    
    SelectObject hMainDC, hOldMainBmp
    SelectObject hAndMaskDC, lOldAndMaskBmp
    SelectObject hXorMaskDC, lOldXorMaskBmp
    
    'create the custom cursor.
    With tIcoInfo
        .fIcon = False
        .xHotspot = 0
        .yHotspot = 0
        .hbmMask = hAndMaskBitmap
        .hbmColor = hXorMaskBitmap
    End With
    
    hCursor = CreateIconIndirect(tIcoInfo)
    
    
    'cleanup.
    DeleteDC hMainDC
    DeleteDC hAndMaskDC
    DeleteDC hXorMaskDC
    DeleteObject hAndMaskBitmap
    DeleteObject hXorMaskBitmap
    DeleteObject hOldMainBmp
    DeleteObject lOldAndMaskBmp
    DeleteObject lOldXorMaskBmp

End Sub


'=============================
'// Class Methods
'=============================

Public Sub Add(ByVal Text As String, ByVal Color As Long)

    Call TextToBitmap(Text, Color)
    
End Sub

Public Sub Show()

    Dim tPt As POINTAPI
    Dim lWnUnderCurs As Long
    
    GetCursorPos tPt
    
    lWnUnderCurs = WindowFromPoint(tPt.x, tPt.y)
    
    If GetWindowThreadProcessId(lWnUnderCurs, ByVal 0&) _
    = GetCurrentThreadId Then
    
        Call SetCursor(hCursor)
    
    End If

End Sub

Public Sub Destroy()

     DestroyIcon hCursor

End Sub